Modelling and visualizing data

You will learn how to:

• Implement and customize interactivity in plots
• Leverage input events to fine-tune visualizations
• Use proxies to update plots and maps on-the-fly (appendix)
• Turn simple R plots into powerful Swiss knifes

1 Interactive visualization: The core of Shiny

• Shiny offers the perfect basis for visualization
  • Plots can be modified using UI inputs
  • Seamless integration of interactivity elements (e.g. pan, zoom)
  • Dashboards facilitate the idea of story-telling by providing context to plots

1.1 Good practice examples

• Examples of these concepts can be seen in many Shiny apps, one example is Edward Parker’s COVID-19 tracker

Question

Explore the COVID-19 tracker. Do you think this is a good Shiny app? If so, why? If not, why not?

COVID-19 Tracker

1.2 Plain plotting vs. Shiny

Feature	Plain R	Shiny	Examples
Reactivity	Changes in the visualization have to be changed in the code	Visualizations can be modified on the fly using widgets like drop-down menus	ExPanD
Interactivity	Plots are static raster or vector images	Plots can be dynamic and can be interacted with	COVID-19 tracker
Narrativity	Sense-making happens through manual annotation, e.g. in an article or a presentation	Plots are embedded in a compilation of narrative elements that can tell a coherent story	Freedom of Press Shiny app GRETA Analytics

Medium	Reactivity	Interactivity	Narrativity
Plain image	❌	❌	❌
Paper / report	❌	❌	✅
Dashboard (e.g. Tableau)	❌	☑️	✅
Quarto / RMarkdown	❌	☑️	✅
Traditional website	☑️	✅	✅
Shiny	✅	✅	✅

1.3 Current app state

• In the last sections, we added a table and a plot and linked them to a number of inputs
• The code chunk below contains the current app state
• In this section, we will:
  • Augment the violin plot
  • Add an interactive map

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlot({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
  })
}

shinyApp(ui = ui, server = server)

1.4 Recap: Plotting in Shiny

• Inserting plots in Shiny apps works just like any other UI component
• You need two things: plotOutput() (or similar) in the UI and renderPlot() (or similar) in the server function
  • plotOutput() creates the empty element in the UI where the plot will go
  • renderPlot() renders the plot and updates the UI element every time a reactive dependency is invalidated

2 Data masking

• Data masking means that function arguments are not evaluated traditionally, but captured or “defused” for later use
• This strategy is employed by many functions for plotting or creating tables including the tidyverse (also called “tidy evaluation”)
• In a practical sense, this means you can specify string values such as column names as you would variables
• To learn more about data masking in Shiny, see chapter 20 of Advanced R and chapter 12 of Mastering Shiny

# NSE as "tidy evaluation"
ess %>%
  summarize(mean = mean(trust_eu))

# NSE in base R
subset(ess, select = trust_eu)
with(ess, sum(trust_eu))

2.1 Why is data masking a problem?

• Data masks are a little tricky to handle in higher levels of abstraction, i.e. functions or reactive expressions
• In such cases, we do not need one specific variable, but a dynamically changing variable

plot_df <- function(df, var) {
  ggplot(df) +
    aes(x = var) +
    geom_histogram()
}

plot_df(ess, "trust_eu")

Error in eval(expr, envir, enclos): object 'ess' not found

2.2 Strategy 1: Use tidy pronouns

• Tidyverse functions that feature tidy evaluation support the .data and .env pronouns
• The .data pronoun is a representation of the original data which can be used in a masked environment
• See also the reference of rlang

plot_df <- function(df, var) {
  ggplot(df) +
    aes(x = .data[[var]]) +
    geom_histogram()
}

plot_df(ess, "trust_eu")

2.3 Strategy 2: Convert strings to expressions

• Sometimes, masked expressions can simply be constructed as strings
• One example are formulas (e.g. in lm(y ~ x1 + x2))
• The as.formula function can create formula objects manually

linreg <- function(df, y, x) {
  fm <- paste(y, "~", paste(x, collapse = " + "))
  fm <- as.formula(fm)
  lm(fm, data = df)
}

linreg(ess, y = "trust_eu", x = c("age", "left_right"))

2.4 Strategy 3: Change names

• In case of poorly implemented data masking, no tools are available to inject variables
• One strategy to overcome such situations could be to simply change the object names

plot_df <- function(df, var) {
  df <- df[, var]
  names(df) <- "x"

  ggplot(df) +
    aes(x = x) +
    geom_histogram()
}

plot_df(ess, "trust_eu")

3 Interactivity

• R itself is very bad at interactivity
• Shiny supports some very essential interactivity through plotOutput
  • Not covered in this workshop! For a primer, check out chapter 7.1 of Mastering Shiny
• All of today’s cool kids use interactivity through Javascript interfaces
• Shiny can generally process all kinds of Javascript-based widgets because Shiny apps are HTML documents

3.1 Popular Javascript interfaces

• Examples of Javascript libraries and their corresponding R packages
  • Plotly (covered here)
  • Leaflet (covered here)
  • Highcharts
  • Bokeh
  • D3
  • Apache ECharts
  • Frappe Charts
  • billboard.js
  • apexcharts.js
  • Google Charts
  • amCharts 4
  • Deck.gl
  • WebGL

4 Plotly

• Plotly is an open-source library to create charts that can be interacted with in various way
• It supports several languages including R and Python
• Plotly is arguably the most renowned R package for interactive plotting
• It even motivated an entire book: https://plotly-r.com/

4.1 Plotly’s grammar of graphics

• Similar to ggplot2, R plotly defines its own grammar of graphics
• A plotly canvas is created with plot_ly()
• Additional plot elements can be added through pipes %>% or |>

ess_geo <- readRDS("data/ess_trust_geo.rds")
ess_geo <- mutate(
  ess_geo,
  region = case_match(
    country,
    c("AT", "BE", "CH", "DE", "NL", "PL", "CZ") ~ "Central",
    c("BG", "EE", "HR", "HU", "LT", "LV", "PL", "SI", "SK") ~ "Eastern",
    c("ES", "IT", "PT", "RS", "ME") ~ "Southern",
    c("IS", "SE", "FI", "GB", "IE", "DK") ~ "Northern"
  )
)

plot_ly(
  sf::st_drop_geometry(ess_geo),
  x = ~trust_eu,
  y = ~left_right,
  z = ~age,
  color = ~region,
  text = ~country
) %>%
  add_markers() %>%
  layout(scene = list(
    xaxis = list(title = 'Trust in the EU'),
    yaxis = list(title = 'Left-right placement'),
    zaxis = list(title = 'Age')
  ))

1

Variables such as x, y, z and color are defined as formulas in a call to plot_ly. This is comparable to calling ggplot(aes(x, y, z, color)).

2

The plot type is added through a pipe. This is comparable to ggplot2 functions such as geom_point or geom_bar.

3

Visual sugar is then added by calling layout and manually editing the axis titles.

4.2 Quick and dirty interactivity

• One important advantage of plotly is that you do not need to learn its grammar
• ggplot2 plots can very easily be converted to an interactive plotly plot:

p <- ggplot(iris) +
  geom_point(aes(Sepal.Width, Sepal.Length))
p

ggplotly(p)

4.3 Extending plotly

4.3.1 Customization

• We can extend Plotly objects using three functions:
  • layout() changes the plot organisation (think ggplot2::theme()), e.g.:
    • colors, sizes, fonts, positions, titles, ratios and alignment of all kinds of plot elements
    • updatemenus adds buttons or drop down menus that can change the plot style or layout (see here for examples)
    • sliders adds sliders that can be useful for time series (see here for examples)
  • config() changes interactivity configurations, e.g.:
    • The modeBarButtons options and displaylogo control the buttons in the mode bar
    • toImageButtonOptions controls the format of plot downloads
    • scrollZoom enables or disables zooming by scrolling
  • style() changes data-level attributes (think ggplot2::scale_), e.g.:
    • hoverinfo controls whether tooltips are shown on hover
    • mode controls whether to show points, lines and/or text in a scatter plot
    • hovertext modifies the tooltips texts shown on hover

4.3.2 Schema

• The actual number of options is immense!
• You can explore all options by calling plotly::schema()

schema()

4.3.3 Example

p <- ggplot(iris) +
  geom_point(aes(Sepal.Width, Sepal.Length))

ggplotly(p) %>%
  config(
    modeBarButtonsToRemove = c(
      "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d",
      "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d"
    ),

    displaylogo = FALSE,

    toImageButtonOptions = list(
      format = "svg",
      filename = "plot",
      height = NULL,
      width = NULL
    ),

    scrollZoom = TRUE
  )

1

Removes specified buttons from the modebar.

2

Removes the Plotly logo.

3

Changes the output of snapshots taken of the plot. Setting height and width to NULL keeps the aspect ratio of the plot as it is shown in the app.

4

Enables zooming through scrolling.

4.4 Plotly and Shiny

• Since plotly does not produce static plots like ggplot2, it cannot be served by plotOutput and renderPlot
• Plotly defines two new functions:
  • plotlyOutput on the UI side
  • renderPlotly on the server side

UI:

mainPanel(
  tabsetPanel(
    type = "tabs",
    
    ### Table tab ----
    tabPanel(
      title = "Table",
      div(
        style = "height: 600px; overflow-y: auto;",
        tableOutput("table")
      )
    ),
    
    ### Plot tab ----
    tabPanel(
      title = "Plot",
      plotlyOutput("plot", height = 600)
    )
  )
)

Server:

output$plot <- renderPlotly({
  xvar <- input$xvar
  yvar <- input$yvar
  plot_data <- filtered() %>%
    drop_na() %>%
    mutate(across(where(is.numeric), .fns = as.ordered))
  
  p <- ggplot(plot_data) +
    aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
    geom_violin(fill = "lightblue", show.legend = FALSE) +
    theme_classic()
  ggplotly(p)
})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
}

shinyApp(ui = ui, server = server)

5 Leaflet

• Leaflet is an open-source JavaScript library to create interactive maps
• Like plotly it is one of the most popular applications for interactive mapping
• The leaflet package makes it easy to create interactive maps directly in R
• Leaflet is very light-weight! This is good, but it’s also bad because it means extra work.

5.1 Leaflet’s grammar of graphics

• Just like ggplot2 and plotly, leaflet is inspired by a grammar of graphics
• A map canvas can be created using the leaflet() function
• Additional elements are added through pipes %>% or |>
• Palettes are created using the leaflet::color function family

leaflet(ess_geo) %>%
  addTiles() %>%
  addPolygons(
    weight = 2,
    opacity = 1,
    fillOpacity = 0.7
  )

1

Leaflet supports four types of palettes: Bin, Quantile, Factor, and Numeric. In this case we have a numeric variable.

2

leaflet() is the powerhorse of the leaflet package. It is comparable to ggplot() or plot_ly().

3

addTiles() adds a background map.

4

addPolygons() adds polygons to the map. This function accepts several visual arguments to control, for example, the line width and opacity.

5.2 Adding data

• To add colorized data, we must first define how to color this data
• Leaflet defines four color functions to create a palette:
  • Numeric
  • Bin
  • Quantile
  • Factor
• Depending on the data

pal <- colorNumeric("YlOrRd", domain = NULL)

leaflet(ess_geo) %>%
  addTiles() %>%
  addPolygons(
    fillColor = pal(ess_geo[["trust_eu"]]),
    weight = 2,
    opacity = 1,
    color = "white",
    fillOpacity = 0.7
  )

1

Define a numeric palette with a gradient Yellow-Orange-Red

2

Apply this palette to the data to generate color values

5.3 Adding a legend

• Just like adding data, adding legends has to be done manually
• The addLegend() function

pal <- colorNumeric("YlOrRd", domain = NULL)

leaflet(ess_geo) %>%
  addTiles() %>%
  addPolygons(
    fillColor = pal(ess_geo[["trust_eu"]]),
    weight = 2,
    opacity = 1,
    color = "white",
    fillOpacity = 0.7
  ) %>%
  addLegend(
    position = "bottomleft",
    pal = pal,
    values = ess_geo[["trust_eu"]],
    opacity = 0.7,
    title = "Trust in the EU"
  )

5.4 Adding interactivity

• Right now, the leaflet map cannot be interacted with
• Interactivity has to be added manually
• Two new features:
  • highlightOptions adds a highlight effect when hovering over a polygon
  • labels adds labels that appear when hovering over a polygon
• Caveats:
  • Labels have to be formatted manually, as per usual
  • Beautifully styled labels require some knowledge of HTML and CSS

labels <- sprintf(
  "<strong>%s</strong><br>%s",
  ess_geo$country,
  ess_geo$trust_eu
)
labels <- lapply(labels, HTML)

pal <- colorNumeric("YlOrRd", domain = NULL)

leaflet(ess_geo) %>%
  addTiles() %>%
  addPolygons(
    fillColor = pal(ess_geo[["trust_eu"]]),
    weight = 2,
    opacity = 1,
    color = "white",
    fillOpacity = 0.7,
    highlightOptions = highlightOptions(
      weight = 2,
      color = "#666",
      fillOpacity = 0.7,
      bringToFront = TRUE
    ),
    label = labels
  ) %>%
  addLegend(
    position = "bottomleft",
    pal = pal,
    values = ess_geo[["trust_eu"]],
    opacity = 0.7,
    title = "Trust in the EU"
  )

1

Labels need to be created manually. Here, I generate very essential labels containing the country in bold and the trust value below it.

2

Labels must be explicitly classified as HTML code. This can be done using the shiny::HTML function.

3

Interactivity is then simply added through the label and highlightOptions arguments to addPolygons().

5.5 Leaflet and Shiny

• Again, Leaflet does not produce static plots and thus cannot be served by plotOutput and renderPlot
• The leaflet package defines two functions:
  • leafletOutput to create the canvas in the UI
  • renderLeaflet to render the Leaflet widget in the server function

UI:

mainPanel(
  tabsetPanel(
    type = "tabs",
    
    ### Table tab ----
    tabPanel(
      title = "Table",
      div(
        style = "height: 600px; overflow-y: auto;",
        tableOutput("table")
      )
    ),
    
    ### Plot tab ----
    tabPanel(
      title = "Plot",
      plotlyOutput("plot", height = 600)
    ),
    
    ### Map tab ----
    tabPanel(
      title = "Map",
      leafletOutput("map", height = 600)
    )
  )
)

Server:

output$map <- renderLeaflet({
  var <- input$xvar
  plot_data <- ess_geo[c("country", var)]
  
  # create labels with a bold title and a body
  labels <- sprintf(
    "<strong>%s</strong><br>%s",
    plot_data$country,
    plot_data[[var]]
  )
  labels <- lapply(labels, HTML)
  
  # create a palette for numerics and ordinals
  if (is.ordered(plot_data[[var]])) {
    pal <- colorFactor("YlOrRd", domain = NULL)
  } else {
    pal <- colorNumeric("YlOrRd", domain = NULL)
  }

  # construct leaflet canvas
  leaflet(plot_data) %>%
    # add base map
    addTiles() %>%
    # add choropleths
    addPolygons(
      fillColor = pal(plot_data[[var]]),
      weight = 2,
      opacity = 1,
      color = "white",
      fillOpacity = 0.7,
      # highlight polygons on hover
      highlightOptions = highlightOptions(
        weight = 2,
        color = "#666",
        fillOpacity = 0.7,
        bringToFront = TRUE
      ),
      label = labels
    ) %>%
    # add a legend
    addLegend(
      position = "bottomleft",
      pal = pal,
      values = plot_data[[var]],
      opacity = 0.7,
      title = var
    )
})

library(tidyverse)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    pal <- colorNumeric("YlOrRd", domain = NULL)
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
}

shinyApp(ui = ui, server = server)

6 Reactivity

• We already covered Shiny’s reactivity quite extensively
• Recall:
  • A user changes an input
  • The server processes that input
  • The UI updates
• It turns out, most plotting systems in Shiny support what we will call “plot events”

6.1 Plot events

• A plot event is triggered by a widget if a user interacts with it
• In a sense, plot events are a cross-over of interactivity and reactivity
• A plot event is hidden, i.e. it does not have to be explicitly defined in the UI – it’s just created automatically on the go.
• By far not all widgets define plot events, but the most important plotting frameworks do:
  • plotly defines a plethora of plot events through the event_data function
  • leaflet automatically creates a number of plot events for each map
  • Even basic plotting supports plot events through additional arguments to plotOutput
• To illustrate plot events, we will use leaflet events

6.2 Leaflet’s plot events

• Leaflet events are accessed like so:

input$<Map ID>_<Object type>_<Event type>

• Map ID refers to the input ID given to the leaflet map

6.2.1 Leaflet object types

• “Object type” refers to the geometry, which can be one of:
  • marker for points
  • shape for polygons and lines
  • geojson and topojson for data that was passed in GeoJSON or TopoJSON format

6.2.2 Leaflet event types

• “Event type” refers to the action that is performed on the geometry to trigger the event, one of:
  • click
  • mouseover
  • mouseout

6.2.3 Other events

• Additionally, Leaflet has some more general events:
  • input$<Map ID>_click triggers when the background of the map is clicked
  • input$<Map ID>_bounds provides the bounding box of the current view
  • input$<Map ID>_zoom provides the current zoom level
  • input$<Map ID>_center provides the center point of the current view

7 Proxies

• Similar to plot events, most Shiny plotting frameworks implement what is called proxies
• A proxy is a representation of an existing widget
• Such proxies can be manipulated in place, i.e. they do not need to be re-rendered

7.1 Proxies in Shiny frameworks

• Many Shiny extensions provide proxy functions:
  • DT::dataTableProxy()
  • plotly::plotlyProxy()
  • leaflet::leafletProxy()

7.2 Proxy workflow

1. Initialize an isolated output widget (i.e., no dependencies) / isolate()
2. Create an observer that updates input dependencies / observe()
3. Invalidate an input
4. Remove existing features and add new ones

Reactive graph for proxies

7.3 Manipulating proxies

• Proxies are best combined with functions that add to, remove to, or clear a widget
• The following table summarizes these functions

Category	Add functions	Remove	Clear
tile	addTiles(), addProviderTiles()	removeTiles()	clearTiles()
marker	addMarkers(), addCircleMarkers()	removeMarker()	clearMarkers()
shape	addPolygons(), addPolylines(), addCircles(), addRectangles()	removeShape()	clearShapes()
geojson	addGeoJSON()	removeGeoJSON()	clearGeoJSON()
topojson	addTopoJSON()	removeTopoJSON()	clearTopoJSON()
control	addControl()	removeControl()	clearControls()

7.4 Synthesis: Plot events, proxies, and plot manipulation

• Proxies unleash their potential when combined with plot events and plot manipulation:
• This combination allows users to manipulate plots themselves (e.g. adding or removing elements)
• The following example makes use of all three concepts to create a map that can add and remove simple markers
  • Plot events: input$map_click and input$map_marker_click to register where markers should be added and removed
  • leafletProxy("map"): A proxy is needed to manipulate the map without resetting the view
  • addMarkers and removeMarker to add and remove markers

ui <- fluidPage(
  leafletOutput("map")
)

server <- function(input, output, session) {

  # initial map render
  output$map <- renderLeaflet({
    leaflet() %>%
      addTiles() %>%
      setView(lng = 7, lat = 52, zoom = 7)
  })

  # add marker
  observe({
    click <- input$map_click
    leafletProxy("map") %>%
      addMarkers(lng = click$lng, lat = click$lat, layerId = toString(click))
  }) %>%
    bindEvent(input$map_click)

  # remove marker
  observe({
    click <- input$map_marker_click
    leafletProxy("map") %>%
      removeMarker(click$id)
  }) %>%
    bindEvent(input$map_marker_click)
}

runApp(shinyApp(ui, server))

1

Render the leaflet map once. Note that the render function does not take any dependencies and is thus only run once.

2

Add a marker every time the map is clicked somewhere. Note that the marker is added not to a new map, but to a proxy of the map that is already rendered.

3

Remove a marker that is clicked. Note how the observer is only triggered when a marker is clicked, i.e. when input$map_marker_click is triggered.

8 Exercise session

8.1 Plotly

Exercise 1.1

Add a new tab to the app. Add an output canvas to the UI and a render function to the server function such that the new tab is able to display an interactive plotly widget.

Solution 1.2

In the UI, add a new tabPanel() to the tabsetPanel().

mainPanel(
  tabsetPanel(
    type = "tabs",
    
    ### Table tab ----
    tabPanel(
      title = "Table",
      div(
        style = "height: 600px; overflow-y: auto;",
        tableOutput("table")
      )
    ),
    
    ### Plot tab ----
    tabPanel(
      title = "Plot",
      plotlyOutput("plot", height = 600)
    ),
    
    ### Map tab ----
    tabPanel(
      title = "Map",
      leafletOutput("map", height = 600)
    ),

    ### New tab ----
    tabPanel(
      title = "Histogram",
      plotlyOutput("hist", height = 600)
    )
  )
)

In the server function, add renderPlotly and assign it to the output object.

output$hist <- renderPlotly({

})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("data/ess_trust.rds")
ess_geo <- readRDS("data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),

        ### New tab ----
        tabPanel(
          title = "Histogram",
          plotlyOutput("hist", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  output$hist <- renderPlotly({
    
  })
}

shinyApp(ui = ui, server = server)

Exercise 1.2

In section 3, we implemented a bivariate plot of the ESS data. For this exercise, create a univariate plotly plot of one of the trust variables. In the solution, I will be using a histogram, but this could also be a stacked bar chart, a kernel density curve, etc. The idea is to get a quick overview of the statistical distribution of a trust variable.

You can do this either through plotly’s own grammar (plot_ly()) or by converting a ggplot (ggplotly()). In the solutions, I will be using plotly though.

Note that, due to a bug in plotly, the labels of the ESS dataset have to be removed from the dataset. This can be done either by casting as.numeric on a variable or by zapping labels with haven::zap_labels().

Solution 1.2

The following solution implements a histogram of the trust_parliament variable.

ess <- readRDS("data/ess_trust.rds")

plot_ly(ess, x = ~as.numeric(trust_parliament)) %>%
  add_histogram()

Exercise 1.3

Customize the plotly plot according to the following requests:

• Change the axis titles to something useful
• Decrease the opacity to 70%
• Remove the modebar
• Increase the gap between histogram bars to 20%.
• Change the bar color to green

Tip

Recall that plotly can be customized using the layout, style, and config functions.

To find out about options specific to a plotly histogram, call plotly::schema() and navigate to traces -> histogram.

Plotly can be very confusing and there is no shame in using google!

Solution 1.3

plot_ly(ess) %>%
  add_histogram(x = ~as.numeric(trust_parliament)) %>%

  # everything that changes the overall theming goes here
  layout(
      xaxis = list(title = "Trust in the national parliament"),
      yaxis = list(title = "Observations"),
      bargap = 0.2
  ) %>%

  # everything that changes the data- and plot-specific theming goes here
  style(opacity = 0.7, marker = list(color = "green")) %>%

  # everything that changes the interactivity goes here
  config(displayModeBar = FALSE)

Exercise 1.4

Implement the plot from exercise 1.3 in the Shiny app. Instead of plotting a single static variable, link the histogram to the input selector for the dependent variable (input$xvar) such that choosing a different trust variable updates the histogram.

Solution 1.4

output$hist <- renderPlotly({
  plot_ly(filtered()) %>%
  add_histogram(x = as.numeric(ess[input$xvar])) %>%

  # everything that changes the overall theming goes here
  layout(
      xaxis = list(title = "Trust in the national parliament"),
      yaxis = list(title = "Observations"),
      bargap = 0.2
  ) %>%

  # everything that changes the data- and plot-specific theming goes here
  style(opacity = 0.7, marker = list(color = "green")) %>%

  # everything that changes the interactivity goes here
  config(displayModeBar = FALSE)
})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),
        
        ### New tab ----
        tabPanel(
          title = "Histogram",
          plotlyOutput("hist", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  output$hist <- renderPlotly({
    plot_ly(filtered()) %>%
      add_histogram(x = as.numeric(ess[[input$xvar]])) %>%
      
      # everything that changes the overall theming goes here
      layout(
        xaxis = list(title = input$xvar),
        yaxis = list(title = "Observations"),
        bargap = 0.2
      ) %>%
      
      # everything that changes the data- and plot-specific theming goes here
      style(opacity = 0.7, marker = list(color = "green")) %>%
      
      # everything that changes the interactivity goes here
      config(displayModeBar = FALSE)
  })
}

shinyApp(ui = ui, server = server)

8.2 Leaflet

Exercise 2.1

Add a new tab to the app. Add an output canvas to the UI and a render function to the server function such that the new tab is able to display an interactive leaflet widget.

Solution 2.1

In the UI, add a new tabPanel() to the tabsetPanel().

mainPanel(
  tabsetPanel(
    type = "tabs",
    
    ### Table tab ----
    tabPanel(
      title = "Table",
      div(
        style = "height: 600px; overflow-y: auto;",
        tableOutput("table")
      )
    ),
    
    ### Plot tab ----
    tabPanel(
      title = "Plot",
      plotlyOutput("plot", height = 600)
    ),
    
    ### Map tab ----
    tabPanel(
      title = "Map",
      leafletOutput("map", height = 600)
    ),

    ### New tab ----
    tabPanel(
      title = "Countries",
      leafletOutput("countrymap", height = 600)
    )
  )
)

In the server function, add renderLeaflet and assign it to the output object.

output$hist <- renderLeaflet({

})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("data/ess_trust.rds")
ess_geo <- readRDS("data/ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),

        ### New tab ----
        tabPanel(
          title = "Histogram",
          leafletOutput("hist", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  output$hist <- renderLeaflet({
    
  })
}

shinyApp(ui = ui, server = server)

Exercise 2.2

In section 4, we added an interactive map showing the average of the ESS dataset across Europe. For this exercise, create an interactive map that maps one of the trust variables using a binned scale. Add a basemap, polygons, a legend, and set the default view on Southeastern Europe.

Solution 2.2

• colorBin creates a binned palette function to use in Leaflet. The domain argument must be passed, else the legend will be empty
• addTiles adds an OpenStreetMap basemap
• setView zooms in to a specific location
• addPolygons adds polygon data to the map
  • The fillColor argument takes a vector of colors which can be created using the pal palette function
• addLegend adds the legend

ess_geo <- readRDS("data/ess_trust_geo.rds")

pal <- colorBin("YlOrRd", domain = ess_geo$trust_eu)

leaflet(ess_geo) %>%
  addTiles() %>%
  setView(13, 45, 5) %>%
  addPolygons(
    fillColor = ~pal(trust_eu)
  ) %>%
  addLegend(
    pal = pal,
    values = ~trust_eu
  )

Exercise 2.3

Customize the map from exercise 2.2 according to the following requests:

• Increase the fill opacity to 60%
• Replace the polygon borders with small, opaque, black lines
• Replace the OpenStreetMap basemap with a Stamen basemap
• Add a small blue dot where GESIS Mannheim is (Longitude: 8.46°, Latitude: 49.48°)
• Move the legend to the bottomleft and make it opaque

Solution 2.3

• Fill opacity is controlled with the fillOpacity argument to addPolygons
• Border size is controlled with the weight argument
• Border opacity is controlled with the opacity argument
• Border color is controlled with the color argument
• Basemaps from known providers can be added with the addProviderTiles function
• Dots can be added with the addCircleMarkers function
  • To control color and size, you can use the color, fillOpacity, opacity, and radius arguments
• Legend positioning is controlled with the position argument of addLegend

pal <- colorBin("YlOrRd", domain = ess_geo$trust_eu)

leaflet(ess_geo) %>%
    addProviderTiles("Stadia.StamenTerrain") %>%
    setView(13, 45, 5) %>%
    addPolygons(
      fillColor = ~pal(trust_eu),
      color = "black",
      opacity = 1,
      weight = 1,
      fillOpacity = 0.6
    ) %>%
    addLegend(
      pal = pal,
      values = ~trust_eu,
      position = "bottomright",
      opacity = 1
    ) %>%
    addCircleMarkers(
      lng = 8.46,
      lat = 49.48,
      color = "blue",
      fillOpacity = 1,
      opacity = 1,
      radius = 3
    )

Exercise 2.4

In section 4, we added labels that appear when hovering over a polygon. In this exercise, add labels that appear when clicking on the GESIS marker from the last exercise. The label should read “This is GESIS in Mannheim, DE” (incl. formatting).

Solution 2.3

pal <- colorBin("YlOrRd", domain = ess_geo$trust_eu)
popup <- HTML("This is <strong>GESIS</strong> in Mannheim, DE")

leaflet(ess_geo) %>%
    addProviderTiles("Stadia.StamenTerrain") %>%
    setView(13, 45, 5) %>%
    addPolygons(
      fillColor = ~pal(trust_eu),
      color = "black",
      opacity = 1,
      weight = 1,
      fillOpacity = 0.6
    ) %>%
    addLegend(
      pal = pal,
      values = ~trust_eu,
      position = "bottomright",
      opacity = 1
    ) %>%
    addCircleMarkers(
      lng = 8.46,
      lat = 49.48,
      color = "blue",
      fillOpacity = 1,
      opacity = 1,
      radius = 3,
      popup = popup
    )

Exercise 2.5

Implement the leafelt map from exercise 2.2 to 2.4 in the Shiny app. Instead of plotting a single static variable, link the histogram to the input selector for the dependent variable (input$xvar) such that choosing a different trust variable updates the histogram.

Solution 2.5

output$gmap <- renderLeaflet({
  xvar <- input$xvar
  pal <- colorBin("YlOrRd", domain = ess_geo[[xvar]])
  popup <- HTML("This is <strong>GESIS</strong> in Mannheim, DE")

  leaflet(ess_geo) %>%
    addProviderTiles("Stadia.StamenTerrain") %>%
    setView(13, 45, 5) %>%
    addPolygons(
      fillColor = pal(ess_geo[[xvar]]),
      color = "black",
      opacity = 1,
      weight = 1,
      fillOpacity = 0.6
    ) %>%
    addLegend(
      pal = pal,
      values = ess_geo[[xvar]],
      position = "bottomright",
      opacity = 1
    ) %>%
    addCircleMarkers(
      lng = 8.46,
      lat = 49.48,
      color = "blue",
      fillOpacity = 1,
      opacity = 1,
      radius = 3,
      popup = popup
    )
})

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),
        
        ### New tab ----
        tabPanel(
          title = "GESIS map",
          leafletOutput("gmap", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  # plot gesis map
  output$gmap <- renderLeaflet({
    xvar <- input$xvar
    pal <- colorBin("YlOrRd", domain = ess_geo[[xvar]])
    popup <- HTML("This is <strong>GESIS</strong> in Mannheim, DE")

    leaflet(ess_geo) %>%
      addProviderTiles("Stadia.StamenTerrain") %>%
      setView(13, 45, 5) %>%
      addPolygons(
        fillColor = pal(ess_geo[[xvar]]),
        color = "black",
        opacity = 1,
        weight = 1,
        fillOpacity = 0.6
      ) %>%
      addLegend(
        pal = pal,
        values = ess_geo[[xvar]],
        position = "bottomright",
        opacity = 1
      ) %>%
      addCircleMarkers(
        lng = 8.46,
        lat = 49.48,
        color = "blue",
        fillOpacity = 1,
        opacity = 1,
        radius = 3,
        popup = popup
      )
  })
}

shinyApp(ui = ui, server = server)

8.3 Proxies and plot events

Exercise 3.1

Taking the body of a server function below, how can you modify a proxy of the plot output every time the input is updated? Add a reactive expression that accesses the plot proxy on each input update.

output$map <- renderPlotly({
  var <- input$variable
  plot_ly(x = ess[[var]]) %>%
    add_histogram()
})

Tip

A proxy typically resides in an observer.

How can you ensure that the observer triggers when the input is updated?

Solution 3.1

output$map <- renderPlotly({
  var <- input$variable
  plot_ly(x = ess[[var]]) %>%
    add_histogram()
})

observe({
  plotlyProxy("plot")
}) %>%
  bindEvent(input$variable)

Exercise 3.2

Taking the code below, implement a proxy of the Leaflet map, that is, whenever the map is updated update the map proxy (leafletProxy()) instead of re-rendering the map. What are the advantages of updating the map using a proxy?

Note that you need to isolate input$xvar in renderLeaflet(). This step is necessary in order to render the leaflet map exactly once. You can isolate an input by typing isolate(input$xvar). Isolation severs an input from the reactive graph.

library(dplyr)
library(tidyr)
library(shiny)
library(leaflet)
library(haven)

ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
    ),
    
    ## Main panel ----
    mainPanel(leafletOutput("map", height = 600))
  )
)


# Server ----
server <- function(input, output, session) {
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create a palette for numerics and ordinals
    pal <- colorNumeric("YlOrRd", domain = NULL)
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        )
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
}

shinyApp(ui = ui, server = server)

Tip

The workflow to update the map using a proxy is the following:

1. Render the map once using renderLeaflet()
2. Everytime the map is updated (by changing input$xvar), trigger an observer
3. The observer changes leafletProxy("map")
4. Using the proxy, clear all polygons and add the updated polygons

You can clear the existing polygons and the legend using the leaflet::clearShapes() and leaflet::clearControls() functions.

Solution 3.2

A solution for exercise 3.1 is presented in the collapsed code chunk below. A proxy is implemented by first rendering the map once through renderLeaflet and then triggering an observer each time the map is updated. The observer contains a call to leafletProxy which updates the map in place instead of re-rendering.

Although the proxy does not serve any important purpose in this case, there are two key advantages which can be observed in the result:

1. The map becomes much snappier, that means the updates are shown much faster than before
2. The map view does not reset when the map updates. You can preserve the pan position and zoom level

These advantages might be irrelevant in this scenario, but can come in handy in more specific use cases.

library(dplyr)
library(tidyr)
library(shiny)
library(leaflet)
library(haven)

ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
    ),
    
    ## Main panel ----
    mainPanel(leafletOutput("map", height = 600))
  )
)


# Server ----
server <- function(input, output, session) {
  # render map ----
  output$map <- renderLeaflet({
    var <- isolate(input$xvar)
    ess_geo <- ess_geo[c("country", var)]
    
    # create a palette for numerics and ordinals
    pal <- colorNumeric("YlOrRd", domain = NULL)
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        )
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  
  # map proxy
  observe({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    pal <- colorNumeric("YlOrRd", domain = NULL)
    
    leafletProxy("map") %>%
      clearShapes() %>%
      clearControls() %>%
      addPolygons(
        data = ess_geo,
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        )
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  }) %>%
    bindEvent(input$xvar)
}

shinyApp(ui = ui, server = server)

Exercise 3.3

Taking the code from exercise 3.1, add a proxy that adds small blue dots when clicking anywhere on one of the polygons.

Tip

The proxy should only be triggered in case of a specific plot event. How can this plot event be accessed?

To add a blue dot, see the addCircleMarkers function.

Solution 3.3

To add a blue dot when a user clicks on a polygon, add a observer that holds a proxy to “map” and depends on input$map_click_shape

observe({
  
}) %>%
  bindEvent()

Exercise 3.4

So far, we have only talked about plot events in Leaflet. Taking the code below, implement an observer that prints the current plot coordinates every time the plot legend is double-clicked. Use plotly’s event_data() function.

library(tidyverse)
library(shiny)
library(plotly)
library(haven)

ess <- readRDS("ess_trust.rds")

# UI ----
ui <- fluidPage(
  plotlyOutput("plot", height = 600),
  br(),
  verbatimTextOutput("text", placeholder = TRUE)
)


# Server ----
server <- function(input, output, session) {
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- ess[ess$country %in% "FR", ] %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[["left_right"]], y = .data[["trust_eu"]], group = .data[["left_right"]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    plotly::ggplotly(p)
  })
}

shinyApp(ui = ui, server = server)

Solution 3.4

A solution for exercise 3.4 is presented in the collapsed code chunk below.

8.4 Beyond plotly and leaflet

Exercise 4.1

Thinking back to the list of Javascript libraries for interactive plotting in section 2.1, pick one R interface that appeals to you the most. Study its documentation and vignettes to get a basic understanding of the interface.

Exercise 4.2

Add a new tab to the app. Replicate the violin plots from section 3 as boxplots using an R interface of your choice.

Note that not all plotting libraries support violin and boxplots to the same degree.

Example solution 4.2

An example solution with the highcharter package:

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)
library(highcharter)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),
        
        ### Highcharts tab ----
        tabPanel(
          title = "Highcharts",
          highchartOutput("highcharts", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  # render highcharts
  output$highcharts <- renderHighchart({
    xvar <- input$xvar
    yvar <- input$yvar
    
    ess <- filtered() %>%
      zap_labels() %>%
      na.omit() %>%
      select(all_of(c(xvar, yvar))) %>%
      setNames(c("x", "y"))
    
    highchart() %>%
      hc_add_series_list(data_to_boxplot(
        ess,
        x,
        y,
        color = "black",
        fillColor = "#ADD8E6",
        showInLegend = FALSE,
        name = xvar
      )) %>%
      hc_yAxis(
        min = 0, max = max(ess$y, na.rm = TRUE),
        title = list(text = yvar)
      ) %>%
      hc_xAxis(type = "category", title = list(text = xvar)) %>%
      hc_legend(enabled = FALSE)
  })
}

shinyApp(ui = ui, server = server)

An example solution with the apexcharter package:

library(dplyr)
library(tidyr)
library(shiny)
library(plotly)
library(leaflet)
library(haven)
library(apexcharter)

ess <- readRDS("ess_trust.rds")
ess_geo <- readRDS("ess_trust_geo.rds")

# UI ----
ui <- fluidPage(
  titlePanel("European Social Survey - round 10"),
  
  ## Sidebar ----
  sidebarLayout(
    sidebarPanel(
      ### select dependent variable
      selectInput(
        "xvar",
        label = "Select a dependent variable",
        choices = c(
          "Trust in country's parliament" = "trust_parliament",
          "Trust in the legal system" = "trust_legal",
          "Trust in the police" = "trust_police",
          "Trust in politicians" = "trust_politicians",
          "Trust in political parties" = "trust_parties",
          "Trust in the European Parliament" = "trust_eu",
          "Trust in the United Nations" = "trust_un"
        )
      ),
      
      ### select a variable ----
      selectInput(
        "yvar",
        label = "Select an independent variable",
        choices = c(
          "Placement on the left-right scale" = "left_right",
          "Age" = "age",
          "Feeling about household's income" = "income_feeling",
          "How often do you use the internet?" = "internet_use",
          "How happy are you?" = "happiness"
        )
      ),
      
      ### select a country ----
      selectizeInput(
        "countries",
        label = "Filter by country",
        choices = unique(ess$country),
        selected = "FR",
        multiple = TRUE
      ),
      
      ### filter values ----
      sliderInput(
        "range",
        label = "Set a value range",
        min = min(ess$trust_parliament, na.rm = TRUE),
        max = max(ess$trust_parliament, na.rm = TRUE),
        value = range(ess$trust_parliament, na.rm = TRUE),
        step = 1
      )
    ),
    
    ## Main panel ----
    mainPanel(
      tabsetPanel(
        type = "tabs",
        
        ### Table tab ----
        tabPanel(
          title = "Table",
          div(
            style = "height: 600px; overflow-y: auto;",
            tableOutput("table")
          )
        ),
        
        ### Plot tab ----
        tabPanel(
          title = "Plot",
          plotlyOutput("plot", height = 600)
        ),
        
        ### Map tab ----
        tabPanel(
          title = "Map",
          leafletOutput("map", height = 600)
        ),
        
        ### Highcharts tab ----
        tabPanel(
          title = "Highcharts",
          apexchartOutput("highcharts", height = 600)
        )
      )
    )
  )
)


# Server ----
server <- function(input, output, session) {
  # update slider ----
  observe({
    var <- na.omit(ess[[input$xvar]])
    is_ordered <- is.ordered(var)
    var <- as.numeric(var)
    updateSliderInput(
      inputId = "range",
      min = min(var),
      max = max(var),
      value = range(var),
      step = if (is_ordered) 1
    )
  }) %>%
    bindEvent(input$xvar)
  
  # filter data ----
  filtered <- reactive({
    req(input$countries, cancelOutput = TRUE)
    
    xvar <- input$xvar
    yvar <- input$yvar
    range <- input$range
    
    # select country
    ess <- ess[ess$country %in% input$countries, ]
    
    # select variable
    ess <- ess[c("idno", "country", xvar, yvar)]
    
    # apply range
    ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ]
    ess
  })
  
  # render table ----
  output$table <- renderTable({
    filtered()
  }, height = 400)
  
  # render plot ----
  output$plot <- renderPlotly({
    xvar <- input$xvar
    yvar <- input$yvar
    plot_data <- filtered() %>%
      drop_na() %>%
      mutate(across(where(is.numeric), .fns = as.ordered))
    
    p <- ggplot(plot_data) +
      aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +
      geom_violin(fill = "lightblue", show.legend = FALSE) +
      theme_classic()
    ggplotly(p)
  })
  
  # render map ----
  output$map <- renderLeaflet({
    var <- input$xvar
    ess_geo <- ess_geo[c("country", var)]
    
    # create labels with a bold title and a body
    labels <- sprintf(
      "<strong>%s</strong><br>%s",
      ess_geo$country,
      ess_geo[[var]]
    )
    labels <- lapply(labels, HTML)
    
    # create a palette for numerics and ordinals
    if (is.ordered(ess_geo[[var]])) {
      pal <- colorFactor("YlOrRd", domain = NULL)
    } else {
      pal <- colorNumeric("YlOrRd", domain = NULL)
    }
    
    # construct leaflet canvas
    leaflet(ess_geo) %>%
      # add base map
      addTiles() %>%
      # add choropleths
      addPolygons(
        fillColor = pal(ess_geo[[var]]),
        weight = 2,
        opacity = 1,
        color = "white",
        fillOpacity = 0.7,
        # highlight polygons on hover
        highlightOptions = highlightOptions(
          weight = 2,
          color = "#666",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label = labels
      ) %>%
      # add a legend
      addLegend(
        position = "bottomleft",
        pal = pal,
        values = ess_geo[[var]],
        opacity = 0.7,
        title = var
      )
  })
  
  # render highcharts
  output$highcharts <- renderApexchart({
    xvar <- input$xvar
    yvar <- input$yvar
    
    apex(filtered(), aes(.data[["trust_eu"]], .data[["left_right"]]), "boxplot") %>%
      ax_plotOptions(boxPlot = boxplot_opts(color.upper = "#ADD8E6", color.lower = "#ADD8E6")) %>%
      ax_stroke(colors = list("black")) %>%
      ax_labs(x = "eu_trust", y = "left_right")
  })
}

shinyApp(ui = ui, server = server)